home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
pascal
/
pascal_t.lha
/
another_wirth
next >
Wrap
Text File
|
1993-07-28
|
67KB
|
1,843 lines
From barbey@disuns2.epfl.ch Fri May 10 09:56:57 1991
Received: from chx400.switch.ch by neuron.tamu.edu (AA22290); Fri, 10 May 91 09:56:14 CDT
X400-Received: by mta chx400.switch.ch in /PRMD=switch/ADMD=arcom/C=CH/;
Relayed; Fri, 10 May 1991 16:56:56 +0200
X400-Received: by /PRMD=SWITCH/ADMD=ARCOM/C=CH/; Relayed;
Fri, 10 May 1991 17:52:51 +0200
Date: Fri, 10 May 1991 14:56:56 +0000
X400-Originator: barbey@disuns2.epfl.ch
X400-Mts-Identifier: [/PRMD=SWITCH/ADMD=ARCOM/C=CH/;9105101452.AA02428]
X400-Content-Type: P2-1984 (2)
From: barbey@disuns2.epfl.ch
Message-Id: <9105101452.AA02428@disun15.disuns2.epfl.ch>
To: "(Tim McGuire)" <mcguire@cs.tamu.edu>
Subject: Re: Wirth's Pascal-S compiler
Received: from disun15 by SIC.Epfl.CH via INTERNET ; Fri, 10 May 91 16:53:55 N
Return-Path: <barbey@disuns2.epfl.ch>
Status: R
In article <9104241654.AA03830@neuron> you write:
> I am looking for the source for Wirth's Pascal-S compiler. I'd like to
> give it to my compiler design students for them to play with. I have
> the hardcopy (from Barron's PASCAL: The Language and Its Implementation)
> but, lazy person that I am, I have no desire to type it in. Does anyone
> have it available, either by ftp or e-mail? I would prefer the original
> version if possible. I hear that R.E. Berry did some modifications and
> included them in his book on program translation, but I don't have it
> available. Berry's version would be acceptable.
>
> I would appreciate any leads you could give me.
>
> Thanks,
>
> Tim McGuire
> mcguire@cs.tamu.edu
> --
You'll find enclosed the source of the original Wirth's PASCAL-S compiler.
We use it at the Swiss Institute of Technology - Lausanne (EPFL) in a
Compiler Design Class. The exercise was to transform it in an Object
Pascal... Email me if you need more infos (syntax, ...) on that.
I've been told that Wirth himself still use it in Swiss Institute of Technology
- Zurich for his Compoiler Design Class.
-Stephane
--------------------------------------------------------------------------
Stephane Barbey
barbey@eldi.epfl.ch
barbey@disuns2.epfl.ch
--------------------------------------------------------------------------
PROGRAM pascals(input,output);
(*author: n.wirth, e.t.h. ch-8092 zurich, 1.3.76*)
(* version originale utilisee au cours compilation *)
LABEL 99;
CONST nkw = 27; (*no. of key words*)
alng = 12; (*no. of significant chars in identifiers*)
llng = 72; (*input ,line length*)
emax = 38; (*max exponent of real numbers*)
emin =-38; (*min exponent*)
kmax = 12; (*max no. of significant digits*)
tmax = 100; (*size of table*)
bmax = 20; (*size of block-table*)
amax = 30; (*size of array-table*)
c2max = 20; (*size of real constant table*)
csmax = 30; (*max no. of cases*)
cmax = 850; (*size of code*)
lmax = 7; (*maximum level*)
smax = 600; (*size of string-table*)
ermax = 58; (*max error no.*)
omax = 63; (*highest order code*)
xmax = 32767; (* 2**15 - 1 (LN) *)
nmax = maxint; (* 2**31 - 1 (LN) *)
lineleng = 132; (*output line length*)
linelimit = 200;
stacksize = 1450;
TYPE symbol = (intcon,realcon,charcon,string,
notsy,plus,minus,times,idiv,rdiv,imod,andsy,orsy,
eql,neq,gtr,geq,lss,leq,
lparent,rparent,lbrack,rbrack,comma,semicolon,period,
colon,becomes,constsy,typesy,varsy,functionsy,
proceduresy,arraysy,recordsy,programsy,ident,
beginsy,ifsy,casesy,repeatsy,whilesy,forsy,
endsy,elsesy,untilsy,ofsy,dosy,tosy,downtosy,thensy);
pstatus =(run,fin,caschk,divchk,inxchk,stkchk,linchk,lngchk,redchk,
iopr,igdm,ifof,ifuf,idof,ioerr,symberr,errcall);
index = -xmax .. +xmax;
alfa = PACKED ARRAY [1..alng] OF char;
object = (konstant,variable,type1,prozedure,funktion);
types = (notyp,ints,reals,bools,chars,arrays,records);
symset = SET OF symbol;
typset = SET OF types;
item = RECORD
typ: types; ref: index;
END ;
order = PACKED RECORD
f: -omax..+omax;
x: -lmax..+lmax;
y: -1073741824..1073741823; (* (LN) *)
END ;
VAR sy: symbol; (*last symbol read by insymbol*)
id: alfa; (*identifier from insymbol*)
inum: integer; (*integer from insymbol*)
rnum: real; (*real number from insymbol*)
sleng: integer; (*string length*)
ch: char; (*last character read from source program*)
line: ARRAY [1..llng] OF char;
cc: integer; (*character counter*)
lc: integer; (*program location counter*)
ll: integer; (*length of current line*)
errs: SET OF 0..ermax;
errpos: integer;
progname: alfa;
iflag, oflag, skipflag: boolean;
constbegsys,typebegsys,blockbegsys,facbegsys,statbegsys: symset;
key: ARRAY [1..nkw] OF alfa;
ksy: ARRAY [1..nkw] OF symbol;
sps: ARRAY [char] OF symbol; (*special symbols*)
t,a,b,sx,c1,c2: integer; (*indices to tables*)
stantyps: typset;
display: ARRAY [0 .. lmax] OF integer;
tab: ARRAY [0 .. tmax] OF (*identifier table*)
PACKED RECORD
name: alfa; link: index;
obj: object; typ: types;
ref: index; normal: boolean;
lev: 0 .. lmax; adr: integer;
END ;
atab: ARRAY [1 .. amax] OF (*array-table*)
PACKED RECORD
inxtyp, eltyp: types;
elref, low, high, elsize, size: index;
END ;
btab: ARRAY [1 .. bmax] OF (*block-table*)
PACKED RECORD
last, lastpar, psize, vsize: index
END ;
stab: PACKED ARRAY [0..smax] OF char; (*string table*)
rconst: ARRAY [1 .. c2max] OF real;
code: ARRAY [0 .. cmax] OF order;
ps : pstatus;
PROCEDURE errormsg;
VAR k: integer;
msg: ARRAY [0..ermax] OF alfa;
BEGIN
msg[ 0] := 'undef id '; msg[ 1] := 'multi def ';
msg[ 2] := 'identifier '; msg[ 3] := 'program ';
msg[ 4] := ') '; msg[ 5] := ': ';
msg[ 6] := 'syntax '; msg[ 7] := 'ident, var ';
msg[ 8] := 'of '; msg[ 9] := '( ';
msg[10] := 'id, array '; msg[11] := '[ ';
msg[12] := '] '; msg[13] := '.. ';
msg[14] := '; '; msg[15] := 'func. type ';
msg[16] := '= '; msg[17] := 'boolean ';
msg[18] := 'convar typ '; msg[19] := 'type ';
msg[20] := 'prog.param '; msg[21] := 'too big ';
msg[22] := '. '; msg[23] := 'typ (case) ';
msg[24] := 'character '; msg[25] := 'const id ';
msg[26] := 'index type '; msg[27] := 'indexbound ';
msg[28] := 'no array '; msg[29] := 'type id ';
msg[30] := 'undef type '; msg[31] := 'no record ';
msg[32] := 'boole type '; msg[33] := 'arith type ';
msg[34] := 'integer '; msg[35] := 'types ';
msg[36] := 'param type '; msg[37] := 'variab id ';
msg[38] := 'string '; msg[39] := 'no.of pars ';
msg[40] := 'real numbr '; msg[41] := 'type ';
msg[42] := 'real type '; msg[43] := 'integer ';
msg[44] := 'var, const '; msg[45] := 'var, proc ';
msg[46] := 'types (:=) '; msg[47] := 'typ (case) ';
msg[48] := 'type '; msg[49] := 'store ovfl ';
msg[50] := 'constant '; msg[51] := ':= ';
msg[52] := 'then '; msg[53] := 'until ';
msg[54] := 'do '; msg[55] := 'to downto ';
msg[56] := 'begin '; msg[57] := 'end ';
msg[58] := 'factor ';
k := 0; writeln; writeln(' key words');
WHILE errs <> [] DO
BEGIN WHILE NOT (k IN errs) DO k := k+1;
writeln(k,' ',msg[k]); errs := errs - [k]
END
END (*errormsg*) ;
PROCEDURE endskip;
BEGIN (*underline skipped part of input*)
WHILE errpos < cc DO
BEGIN write('-'); errpos := errpos + 1
END ;
skipflag := false
END (*endskip*) ;
PROCEDURE nextch; (*read next character; process line end*)
BEGIN IF cc = ll THEN
BEGIN IF eof(input) THEN
BEGIN writeln;
writeln(' program incomplete');
errormsg; GOTO 99
END ;
IF errpos <> 0 THEN
BEGIN IF skipflag THEN endskip;
writeln; errpos := 0
END ;
write(lc:5, ' ');
ll := 0; cc := 0;
WHILE NOT eoln(input) DO
BEGIN ll := ll+1; read(ch); write(ch); line[ll] := ch
END ;
writeln; ll := ll+1; line[ll]:=' '; readln
END ;
cc := cc+1; ch := line[cc];
END (*nextch*) ;
PROCEDURE error(n: integer);
BEGIN IF errpos = 0 THEN write(' ****');
IF cc > errpos THEN
BEGIN write(' ': cc-errpos, '^', n:2);
errpos := cc+3; errs := errs + [n]
END
END (*error*) ;
PROCEDURE fatal(n: integer);
VAR msg: ARRAY [1..7] OF alfa;
BEGIN writeln; errormsg;
msg[ 1] := 'identifier '; msg[ 2] := 'procedures ';
msg[ 3] := 'reals '; msg[ 4] := 'arrays ';
msg[ 5] := 'levels '; msg[ 6] := 'code ';
msg[ 7] := 'strings ';
writeln(' compiler table for ', msg[n], ' is too small');
GOTO 99 (* terminate compilation*)
END (*fatal*) ;
(*-----------------------------------------------------------insymbol-*)
PROCEDURE insymbol; (*reads next symbol*)
LABEL 1,2,3;
VAR i,j,k,e: integer;
PROCEDURE readscale;
VAR s, sign: integer;
BEGIN nextch; sign := 1; s := 0;
IF ch = '+' THEN nextch ELSE
IF ch = '-' THEN BEGIN nextch; sign := -1 END ;
IF NOT (ch IN ['0'..'9']) THEN error(40)
ELSE REPEAT s := 10*s + ord(ch) - ord('0'); nextch
UNTIL NOT (ch IN ['0'..'9']);
e := s*sign + e
END (*readscale*) ;
PROCEDURE adjustscale;
VAR s: integer; d,t: real;
BEGIN IF k+e > emax THEN error(21) ELSE
IF k+e < emin THEN rnum := 0 ELSE
BEGIN s := abs(e); t := 1.0; d := 10.0;
REPEAT
WHILE NOT odd(s) DO
BEGIN s := s DIV 2; d := sqr(d)
END ;
s := s-1; t := d*t
UNTIL s = 0;
IF e >= 0 THEN rnum := rnum*t ELSE rnum := rnum/t
END
END (*adjustscale*) ;
BEGIN (*insymbol*)
1: WHILE ch = ' ' DO nextch;
CASE ch OF
'a','b','c','d','e','f','g','h','i',
'j','k','l','m','n','o','p','q','r',
's','t','u','v','w','x','y','z',
'A','B','C','D','E','F','G','H','I',
'J','K','L','M','N','O','P','Q','R',
'S','T','U','V','W','X','Y','Z':
BEGIN (*identifier or wordsymbol*) k := 0; id := ' ';
REPEAT IF k < alng THEN
BEGIN k := k+1;
IF ch IN ['A'..'Z'] THEN
id[k]:=chr(ord(ch)+ord('a')-ord('A'))
ELSE id[k] := ch
END ;
nextch
UNTIL NOT (ch IN ['a'..'z','A'..'Z','0'..'9']);
i := 1; j := nkw; (*binary search*)
REPEAT k := (i+j) DIV 2;
IF id <= key[k] THEN j := k-1;
IF id >= key[k] THEN i := k+1
UNTIL i > j;
IF i-1 > j THEN sy := ksy[k] ELSE sy := ident
END;
'0','1','2','3','4','5','6','7','8','9':
BEGIN (*number*) k := 0; inum := 0; sy := intcon;
REPEAT inum := inum*10 + ord(ch) - ord('0');
k := k+1; nextch
UNTIL NOT (ch IN ['0'..'9']);
IF (k > kmax) OR (inum > nmax) THEN
BEGIN error(21); inum := 0; k := 0
END ;
IF ch = '.' THEN
BEGIN nextch;
IF ch = '.' THEN ch := ':' ELSE
BEGIN sy := realcon; rnum := inum; e := 0;
WHILE ch IN ['0'..'9'] DO
BEGIN e := e-1;
rnum := 10.0*rnum + (ord(ch)-ord('0')); nextch
END ;
IF e = 0 THEN error(40);
IF ch IN ['e','E'] THEN readscale;
IF e <> 0 THEN adjustscale
END
END ELSE
IF ch IN ['e','E'] THEN
BEGIN sy := realcon; rnum := inum; e := 0;
readscale; IF e <> 0 THEN adjustscale
END ;
END;
':': BEGIN nextch;
IF ch = '=' THEN
BEGIN sy := becomes; nextch
END ELSE sy := colon
END ;
'<' : BEGIN nextch;
IF ch = '=' THEN BEGIN sy := leq; nextch END ELSE
IF ch = '>' THEN BEGIN sy := neq; nextch END ELSE sy := lss
END ;
'>' : BEGIN nextch;
IF ch = '=' THEN BEGIN sy := geq; nextch END ELSE sy := gtr
END ;
'.' : BEGIN nextch;
IF ch = '.' THEN
BEGIN sy := colon; nextch
END ELSE sy := period
END ;
'''': BEGIN k := 0;
2: nextch;
IF ch = '''' THEN
BEGIN nextch; IF ch <> '''' THEN GOTO 3
END ;
IF sx+k = smax THEN fatal(7);
stab[sx+k] := ch; k := k+1;
IF cc = 1 THEN
BEGIN (*end of line*) k := 0;
END
ELSE GOTO 2;
3: IF k = 1 THEN
BEGIN sy := charcon; inum := ord(stab[sx])
END ELSE
IF k = 0 THEN
BEGIN error(38); sy := charcon; inum := 0
END ELSE
BEGIN sy := string; inum := sx; sleng := k; sx := sx+k
END
END ;
'(' : BEGIN nextch;
IF ch <> '*' THEN sy := lparent ELSE
BEGIN (*comment*) nextch;
REPEAT
WHILE ch <> '*' DO nextch;
nextch
UNTIL ch = ')';
nextch; GOTO 1
END
END ;
'+', '-', '*', '/', ')', '=', ',', '[', ']', ';' :
BEGIN sy := sps[ch]; nextch
END ;
'$', '!', '@', '\', '^', '_', '?', '"', '&', '#',
'%', '{', '}', '~', '`', '|' :
BEGIN error(24); nextch; GOTO 1
END
END
END (*insymbol*) ;
(*---------------------------------------------------------- enter ---*)
PROCEDURE enter(x0: alfa; x1: object;
x2: types; x3: integer);
BEGIN t := t+1; (*enter standard identifier*)
WITH tab[t] DO
BEGIN name := x0; link := t-1; obj := x1;
typ := x2; ref := 0; normal := true;
lev := 0; adr := x3
END
END (*enter*) ;
PROCEDURE enterarray(tp: types; l,h: integer);
BEGIN IF l > h THEN error(27);
IF (abs(l)>xmax) OR (abs(h)>xmax) THEN
BEGIN error(27); l := 0; h := 0;
END ;
IF a = amax THEN fatal(4) ELSE
BEGIN a := a+1;
WITH atab[a] DO
BEGIN inxtyp := tp; low := l; high := h
END
END
END (*enterarray*) ;
PROCEDURE enterblock;
BEGIN IF b = bmax THEN fatal(2) ELSE
BEGIN b := b+1; btab[b].last := 0; btab[b].lastpar := 0
END
END (*enterblock*) ;
PROCEDURE enterreal(x: real);
BEGIN IF c2 = c2max-1 THEN fatal(3) ELSE
BEGIN rconst[c2+1] := x; c1 := 1;
WHILE rconst[c1] <> x DO c1 := c1+1;
IF c1 > c2 THEN c2 := c1
END
END (*enterreal*) ;
PROCEDURE emit(fct: integer);
BEGIN IF lc = cmax THEN fatal(6);
code[lc].f := fct; lc := lc+1
END (*emit*) ;
PROCEDURE emit1(fct,b: integer);
BEGIN IF lc = cmax THEN fatal(6);
WITH code[lc] DO
BEGIN f := fct; y := b END ;
lc := lc+1
END (*emit1*) ;
PROCEDURE emit2(fct,a,b: integer);
BEGIN IF lc = cmax THEN fatal(6);
WITH code[lc] DO
BEGIN f := fct; x := a; y := b END ;
lc := lc+1
END (*emit2*) ;
PROCEDURE printtables;
VAR i: integer; o: order;
BEGIN
page(output);
writeln(' identifiers link obj typ ref nrm lev adr');
FOR i := btab[1].last +1 TO t DO
WITH tab[i] DO
writeln(i:7,' ',name,link:5, ord(obj):5, ord(typ):5, ref:5,
ord(normal):5, lev:5, adr:5);
writeln;
writeln(' blocks last lpar psze vsze');
FOR i := 1 TO b DO
WITH btab[i] DO
writeln(i:5,' ', last:5, lastpar:5, psize:5, vsize:5);
writeln;
writeln(' arrays xtyp etyp eref low high elsz size');
FOR i := 1 TO a DO
WITH atab[i] DO
writeln(i:5,' ', ord(inxtyp):5, ord(eltyp):5,
elref:5, low:5, high:5, elsize:5, size:5);
writeln;
writeln(' code:');
FOR i := 0 TO lc-1 DO
BEGIN IF i MOD 5 = 0 THEN
BEGIN writeln; write(i:5)
END ;
o := code[i]; write(o.f:5);
IF o.f < 31 THEN
IF o.f < 4 THEN write(o.x:2, o.y:5)
ELSE write(o.y:7)
ELSE write(' ');
write(',')
END ;
writeln
END (*printtables*) ;
(*-------------------------------------------------------------block--*)
PROCEDURE block(fsys: symset; isfun: boolean; level: integer);
TYPE conrec =
RECORD CASE tp: types OF
ints,chars,bools: (i: integer);
reals: (r: real)
END ;
VAR dx: integer; (*data allocation index*)
prt: integer; (*t-index of this procedure*)
prb: integer; (*b-index of this procedure*)
x: integer;
PROCEDURE skip(fsys: symset; n: integer);
BEGIN error(n); skipflag := true;
WHILE NOT (sy IN fsys) DO insymbol;
IF skipflag THEN endskip
END (*skip*) ;
PROCEDURE test(s1,s2: symset; n: integer);
BEGIN IF NOT (sy IN s1) THEN
skip(s1+s2,n)
END (*test*) ;
PROCEDURE testsemicolon;
BEGIN
IF sy = semicolon THEN insymbol ELSE
BEGIN error(14);
IF sy IN [comma,colon] THEN insymbol
END ;
test([ident]+blockbegsys, fsys, 6)
END (*testsemicolon*) ;
PROCEDURE enter(id: alfa; k: object);
VAR j,l: integer;
BEGIN IF t = tmax THEN fatal(1) ELSE
BEGIN tab[0].name := id;
j := btab[display[level]].last; l := j;
WHILE tab[j].name <> id DO j := tab[j].link;
IF j <> 0 THEN error(1) ELSE
BEGIN t := t+1;
WITH tab[t] DO
BEGIN name := id; link := l;
obj := k; typ := notyp; ref := 0; lev := level; adr := 0
END ;
btab[display[level]].last := t
END
END
END (*enter*) ;
FUNCTION loc(id: alfa): integer;
VAR i,j: integer; (*locate id in table*)
BEGIN i := level; tab[0].name := id; (*sentinel*)
REPEAT j := btab[display[i]].last;
WHILE tab[j].name <> id DO j := tab[j].link;
i := i-1;
UNTIL (i<0) OR (j<>0);
IF j = 0 THEN error(0); loc := j
END (*loc*) ;
PROCEDURE entervariable;
BEGIN IF sy = ident THEN
BEGIN enter(id,variable); insymbol
END
ELSE error(2)
END (*entervariable*) ;
PROCEDURE constant(fsys: symset; VAR c: conrec);
VAR x, sign: integer;
BEGIN c.tp := notyp; c.i := 0;
test(constbegsys, fsys, 50);
IF sy IN constbegsys THEN
BEGIN
IF sy = charcon THEN
BEGIN c.tp := chars; c.i := inum; insymbol
END
ELSE
BEGIN sign := 1;
IF sy IN [plus,minus] THEN
BEGIN IF sy = minus THEN sign := -1;
insymbol
END ;
IF sy = ident THEN
BEGIN x := loc(id);
IF x <> 0 THEN
IF tab[x].obj <> konstant THEN error(25) ELSE
BEGIN c.tp := tab[x].typ;
IF c.tp = reals THEN c.r := sign*rconst[tab[x].adr]
ELSE c.i := sign*tab[x].adr
END ;
insymbol
END
ELSE
IF sy = intcon THEN
BEGIN c.tp := ints; c.i := sign*inum; insymbol
END ELSE
IF sy = realcon THEN
BEGIN c.tp := reals; c.r := sign*rnum; insymbol
END ELSE skip(fsys,50)
END;
test(fsys, [], 6)
END
END (*constant*) ;
PROCEDURE typ(fsys: symset; VAR tp: types; VAR rf, sz: integer);
VAR x: integer;
eltp: types; elrf: integer;
elsz, offset, t0,t1: integer;
PROCEDURE arraytyp(VAR aref,arsz: integer);
VAR eltp: types;
low, high: conrec;
elrf, elsz: integer;
BEGIN constant([colon,rbrack,rparent,ofsy]+fsys, low);
IF low.tp = reals THEN
BEGIN error(27); low.tp := ints; low.i := 0
END ;
IF sy = colon THEN insymbol ELSE error(13);
constant([rbrack,comma,rparent,ofsy]+fsys, high);
IF high.tp <> low.tp THEN
BEGIN error(27); high.i := low.i
END ;
enterarray(low.tp, low.i, high.i); aref := a;
IF sy = comma THEN
BEGIN insymbol; eltp := arrays; arraytyp(elrf,elsz)
END ELSE
BEGIN
IF sy = rbrack THEN insymbol ELSE
BEGIN error(12);
IF sy = rparent THEN insymbol
END ;
IF sy = ofsy THEN insymbol ELSE error(8);
typ(fsys,eltp,elrf,elsz)
END ;
WITH atab[aref] DO
BEGIN arsz := (high-low+1)*elsz; size := arsz;
eltyp := eltp; elref := elrf; elsize := elsz
END ;
END (*arraytyp*) ;
BEGIN (*typ*) tp := notyp; rf := 0; sz := 0;
test(typebegsys, fsys, 10);
IF sy IN typebegsys THEN
BEGIN
IF sy = ident THEN
BEGIN x := loc(id);
IF x <> 0 THEN
WITH tab[x] DO
IF obj <> type1 THEN error(29) ELSE
BEGIN tp := typ; rf := ref; sz := adr;
IF tp = notyp THEN error(30)
END ;
insymbol
END ELSE
IF sy = arraysy THEN
BEGIN insymbol;
IF sy = lbrack THEN insymbol ELSE
BEGIN error(11);
IF sy = lparent THEN insymbol
END ;
tp := arrays; arraytyp(rf,sz)
END ELSE
BEGIN (*records*) insymbol;
enterblock; tp := records; rf := b;
IF level = lmax THEN fatal(5);
level := level+1; display[level] := b; offset := 0;
WHILE NOT (sy IN fsys-[semicolon,comma,ident]+[endsy]) DO
BEGIN (*field section*)
IF sy = ident THEN
BEGIN t0 := t; entervariable;
WHILE sy = comma DO
BEGIN insymbol; entervariable
END ;
IF sy = colon THEN insymbol ELSE error(5);
t1 := t;
typ(fsys+[semicolon,endsy,comma,ident],eltp,elrf,elsz);
WHILE t0 < t1 DO
BEGIN t0 := t0+1;
WITH tab[t0] DO
BEGIN typ := eltp; ref := elrf; normal := true;
adr := offset; offset := offset + elsz
END
END
END ;
IF sy <> endsy THEN
BEGIN IF sy = semicolon THEN insymbol ELSE
BEGIN error(14);
IF sy = comma THEN insymbol
END ;
test([ident,endsy,semicolon], fsys, 6)
END
END ;
btab[rf].vsize := offset; sz := offset; btab[rf].psize := 0;
insymbol; level := level-1
END ;
test(fsys, [], 6)
END
END (*typ*) ;
PROCEDURE parameterlist; (*formal parameter list*)
VAR tp: types;
rf, sz, x, t0: integer;
valpar: boolean;
BEGIN insymbol; tp := notyp; rf := 0; sz := 0;
test([ident, varsy], fsys+[rparent], 7);
WHILE sy IN [ident,varsy] DO
BEGIN IF sy <> varsy THEN valpar := true ELSE
BEGIN insymbol; valpar := false
END ;
t0 := t; entervariable;
WHILE sy = comma DO
BEGIN insymbol; entervariable;
END ;
IF sy = colon THEN
BEGIN insymbol;
IF sy <> ident THEN error(2) ELSE
BEGIN x := loc(id); insymbol;
IF x <> 0 THEN
WITH tab[x] DO
IF obj <> type1 THEN error(29) ELSE
BEGIN tp := typ; rf := ref;
IF valpar THEN sz := adr ELSE sz := 1
END ;
END ;
test([semicolon,rparent], [comma,ident]+fsys, 14)
END
ELSE error(5);
WHILE t0 < t DO
BEGIN t0 := t0+1;
WITH tab[t0] DO
BEGIN typ := tp; ref := rf;
normal := valpar; adr := dx; lev := level;
dx := dx + sz
END
END ;
IF sy <> rparent THEN
BEGIN IF sy = semicolon THEN insymbol ELSE
BEGIN error(14);
IF sy = comma THEN insymbol
END ;
test([ident,varsy], [rparent]+fsys, 6)
END
END (*while*) ;
IF sy = rparent THEN
BEGIN insymbol;
test([semicolon,colon], fsys, 6)
END
ELSE error(4)
END (*parameterlist*) ;
PROCEDURE constantdeclaration;
VAR c: conrec;
BEGIN insymbol;
test([ident], blockbegsys, 2);
WHILE sy = ident DO
BEGIN enter(id,konstant); insymbol;
IF sy = eql THEN insymbol ELSE
BEGIN error(16);
IF sy = becomes THEN insymbol
END ;
constant([semicolon,comma,ident]+fsys,c);
tab[t].typ := c.tp; tab[t].ref := 0;
IF c.tp = reals THEN
BEGIN enterreal(c.r); tab[t].adr := c1 END
ELSE tab[t].adr := c.i;
testsemicolon
END
END (*constantdeclaration*) ;
PROCEDURE typedeclaration;
VAR tp: types; rf, sz, t1: integer;
BEGIN insymbol;
test([ident], blockbegsys, 2);
WHILE sy = ident DO
BEGIN enter(id,type1); t1 := t; insymbol;
IF sy = eql THEN insymbol ELSE
BEGIN error(16);
IF sy = becomes THEN insymbol
END ;
typ([semicolon,comma,ident]+fsys, tp, rf, sz);
WITH tab[t1] DO
BEGIN typ := tp; ref := rf; adr := sz
END ;
testsemicolon
END
END (*typedeclaration*) ;
PROCEDURE variabledeclaration;
VAR t0, t1, rf, sz: integer;
tp: types;
BEGIN insymbol;
WHILE sy = ident DO
BEGIN t0 := t; entervariable;
WHILE sy = comma DO
BEGIN insymbol; entervariable;
END ;
IF sy = colon THEN insymbol ELSE error(5);
t1 := t;
typ([semicolon,comma,ident]+fsys, tp, rf, sz);
WHILE t0 < t1 DO
BEGIN t0 := t0+1;
WITH tab[t0] DO
BEGIN typ := tp; ref := rf;
lev := level; adr := dx; normal := true;
dx := dx + sz
END
END ;
testsemicolon
END
END (*variabledeclaration*) ;
PROCEDURE procdeclaration;
VAR isfun: boolean;
BEGIN isfun := sy = functionsy; insymbol;
IF sy <> ident THEN
BEGIN error(2); id := ' '
END ;
IF isfun THEN enter(id,funktion) ELSE enter(id,prozedure);
tab[t].normal := true;
insymbol; block([semicolon]+fsys, isfun, level+1);
IF sy = semicolon THEN insymbol ELSE error(14);
emit(32+ord(isfun)) (*exit*)
END (*proceduredeclaration*) ;
(*---------------------------------------------------------statement--*)
PROCEDURE statement(fsys: symset);
VAR i: integer; (* x: item; (LN) *)
PROCEDURE expression(fsys: symset; VAR x: item); forward;
PROCEDURE selector(fsys: symset; VAR v:item);
VAR x: item; a,j: integer;
BEGIN (*sy in [lparent, lbrack, period]*)
REPEAT
IF sy = period THEN
BEGIN insymbol; (*field selector*)
IF sy <> ident THEN error(2) ELSE
BEGIN
IF v.typ <> records THEN error(31) ELSE
BEGIN (*search field identifier*)
j := btab[v.ref] .last; tab[0].name := id;
WHILE tab[j].name <> id DO j := tab[j].link;
IF j = 0 THEN error(0);
v.typ := tab[j].typ; v.ref := tab[j].ref;
a := tab[j].adr; IF a <> 0 THEN emit1(9,a)
END ;
insymbol
END
END ELSE
BEGIN (*array selector*)
IF sy <> lbrack THEN error(11);
REPEAT insymbol;
expression(fsys+[comma,rbrack], x);
IF v.typ <> arrays THEN error(28) ELSE
BEGIN a := v.ref;
IF atab[a].inxtyp <> x.typ THEN error(26) ELSE
IF atab[a].elsize = 1 THEN emit1(20,a) ELSE emit1(21,a);
v.typ := atab[a].eltyp; v.ref := atab[a].elref
END
UNTIL sy <> comma;
IF sy = rbrack THEN insymbol ELSE
BEGIN error(12); IF sy = rparent THEN insymbol
END
END
UNTIL NOT (sy IN [lbrack,lparent,period]);
test(fsys, [], 6)
END (*selector*) ;
PROCEDURE call(fsys: symset; i: integer);
VAR x: item;
lastp, cp, k: integer;
BEGIN emit1(18,i); (*mark stack*)
lastp := btab[tab[i].ref].lastpar; cp := i;
IF sy = lparent THEN
BEGIN (*actual parameter list*)
REPEAT insymbol;
IF cp >= lastp THEN error(39) ELSE
BEGIN cp := cp+1;
IF tab[cp].normal THEN
BEGIN (*value parameter*)
expression(fsys+[comma,colon,rparent], x);
IF x.typ=tab[cp].typ THEN
BEGIN
IF x.ref <> tab[cp].ref THEN error(36) ELSE
IF x.typ = arrays THEN emit1(22,atab[x.ref].size) ELSE
IF x.typ = records THEN emit1(22,btab[x.ref].vsize)
END ELSE
IF (x.typ=ints) AND (tab[cp].typ=reals) THEN
emit1(26,0) ELSE
IF x.typ<>notyp THEN error(36);
END ELSE
BEGIN (*variable parameter*)
IF sy <> ident THEN error(2) ELSE
BEGIN k := loc(id); insymbol;
IF k <> 0 THEN
BEGIN IF tab[k].obj <> variable THEN error(37);
x.typ := tab[k].typ; x.ref := tab[k].ref;
IF tab[k].normal THEN emit2(0,tab[k].lev,tab[k].adr)
ELSE emit2(1,tab[k].lev,tab[k].adr);
IF sy IN [lbrack,lparent,period] THEN
selector(fsys+[comma,colon,rparent], x);
IF (x.typ<>tab[cp].typ) OR (x.ref<>tab[cp].ref) THEN
error(36)
END
END
END
END ;
test([comma,rparent], fsys, 6)
UNTIL sy <> comma;
IF sy = rparent THEN insymbol ELSE error(4)
END ;
IF cp < lastp THEN error(39); (*too few actual parameters*)
emit1(19, btab[tab[i].ref].psize-1);
IF tab[i].lev < level THEN emit2(3, tab[i].lev, level)
END (*call*) ;
FUNCTION resulttype(a,b: types): types;
BEGIN
IF (a>reals) OR (b>reals) THEN
BEGIN error(33); resulttype := notyp
END ELSE
IF (a=notyp) OR (b=notyp) THEN resulttype := notyp ELSE
IF a=ints THEN
IF b=ints THEN resulttype := ints ELSE
BEGIN resulttype := reals; emit1(26,1)
END
ELSE
BEGIN resulttype := reals;
IF b=ints THEN emit1(26,0)
END
END (*resulttype*) ;
PROCEDURE expression; (* (LN) *)
VAR y:item; op:symbol;
PROCEDURE simpleexpression(fsys:symset; VAR x:item);
VAR y:item; op:symbol;
PROCEDURE term(fsys:symset; VAR x:item);
VAR y:item; op:symbol; (* ts:typset; (LN) *)
PROCEDURE factor(fsys:symset; VAR x:item);
VAR i,f: integer;
PROCEDURE standfct(n: integer);
VAR ts: typset;
BEGIN (*standard function no. n*)
IF sy = lparent THEN insymbol ELSE error(9);
IF n < 17 THEN
BEGIN expression(fsys+[rparent],x);
CASE n OF
(*abs,sqr*) 0,2: BEGIN ts := [ints,reals]; tab[i].typ := x.typ;
IF x.typ = reals THEN n := n+1
END ;
(*odd,chr*) 4,5: ts := [ints];
(*ord*) 6: ts := [ints,bools,chars];
(*succ,pred*) 7,8: BEGIN ts := [ints,bools,chars]; tab[i].typ := x.typ
END ;
(*round,trunc*) 9,10,11,12,13,14,15,16:
(*sin,cos,...*) BEGIN ts := [ints,reals];
IF x.typ = ints THEN emit1(26,0)
END ;
END ;
IF x.typ IN ts THEN emit1(8,n) ELSE
IF x.typ <> notyp THEN error(48);
END ELSE
(*eof,eoln*) BEGIN (*n in [17,18]*)
IF sy <> ident THEN error(2) ELSE
IF id <> 'input ' THEN error(0) ELSE insymbol;
emit1(8,n);
END ;
x.typ := tab[i].typ;
IF sy = rparent THEN insymbol ELSE error(4)
END (*standfct*) ;
BEGIN (*factor*) x.typ := notyp; x.ref := 0;
test(facbegsys, fsys, 58);
WHILE sy IN facbegsys DO
BEGIN
IF sy = ident THEN
BEGIN i := loc(id); insymbol;
WITH tab[i] DO
CASE obj OF
konstant: BEGIN x.typ := typ; x.ref := 0;
IF x.typ = reals THEN
emit1(25,adr) ELSE
emit1(24,adr)
END ;
variable: BEGIN x.typ := typ; x.ref := ref;
IF sy IN [lbrack,lparent,period] THEN
BEGIN IF normal THEN f := 0 ELSE f := 1;
emit2(f, lev, adr);
selector(fsys,x);
IF x.typ IN stantyps THEN emit(34)
END ELSE
BEGIN
IF x.typ IN stantyps THEN
IF normal THEN f := 1 ELSE f := 2
ELSE
IF normal THEN f := 0 ELSE f := 1;
emit2(f, lev, adr)
END
END ;
type1, prozedure: error(44);
funktion :BEGIN x.typ := typ;
IF lev <> 0 THEN call(fsys, i)
ELSE standfct(adr)
END
END (*case,with*)
END ELSE
IF sy IN [charcon,intcon,realcon] THEN
BEGIN
IF sy = realcon THEN
BEGIN x.typ := reals; enterreal(rnum);
emit1(25, c1)
END ELSE
BEGIN IF sy = charcon THEN x.typ := chars
ELSE x.typ := ints;
emit1(24, inum)
END ;
x.ref := 0; insymbol
END ELSE
IF sy = lparent THEN
BEGIN insymbol; expression(fsys+[rparent], x);
IF sy = rparent THEN insymbol ELSE error(4)
END ELSE
IF sy = notsy THEN
BEGIN insymbol; factor(fsys,x);
IF x.typ=bools THEN emit(35) ELSE
IF x.typ<>notyp THEN error(32)
END ;
test(fsys, facbegsys, 6)
END (*while*)
END (*factor*) ;
BEGIN (*term*)
factor(fsys+[times,rdiv,idiv,imod,andsy], x);
WHILE sy IN [times,rdiv,idiv,imod,andsy] DO
BEGIN op := sy; insymbol;
factor(fsys+[times,rdiv,idiv,imod,andsy], y);
IF op = times THEN
BEGIN x.typ := resulttype(x.typ, y.typ);
CASE x.typ OF
notyp: ;
ints : emit(57);
reals: emit(60);
END
END ELSE
IF op = rdiv THEN
BEGIN
IF x.typ = ints THEN
BEGIN emit1(26,1); x.typ := reals
END ;
IF y.typ = ints THEN
BEGIN emit1(26,0); y.typ := reals
END ;
IF (x.typ=reals) AND (y.typ=reals) THEN emit(61) ELSE
BEGIN IF (x.typ<>notyp) AND (y.typ<>notyp) THEN
error(33);
x.typ := notyp
END
END ELSE
IF op = andsy THEN
BEGIN IF (x.typ=bools) AND (y.typ=bools) THEN
emit(56) ELSE
BEGIN IF (x.typ<>notyp) AND (y.typ<>notyp) THEN
error(32);
x.typ := notyp
END
END ELSE
BEGIN (*op in [idiv,imod]*)
IF (x.typ=ints) AND (y.typ=ints) THEN
IF op=idiv THEN emit(58)
ELSE emit(59) ELSE
BEGIN IF (x.typ<>notyp) AND (y.typ<>notyp) THEN
error(34);
x.typ := notyp
END
END
END
END (*term*) ;
BEGIN (*simpleexpression*)
IF sy IN [plus,minus] THEN
BEGIN op := sy; insymbol;
term(fsys+[plus,minus], x);
IF x.typ > reals THEN error(33) ELSE
IF op = minus THEN emit(36)
END ELSE
term(fsys+[plus,minus,orsy], x);
WHILE sy IN [plus,minus,orsy] DO
BEGIN op := sy; insymbol;
term(fsys+[plus,minus,orsy], y);
IF op = orsy THEN
BEGIN
IF (x.typ=bools) AND (y.typ=bools) THEN emit(51) ELSE
BEGIN IF (x.typ<>notyp) AND (y.typ<>notyp) THEN
error(32);
x.typ := notyp
END
END ELSE
BEGIN x.typ := resulttype(x.typ, y.typ);
CASE x.typ OF
notyp: ;
ints : IF op = plus THEN emit(52)
ELSE emit(53);
reals: IF op = plus THEN emit(54)
ELSE emit(55)
END
END
END
END (*simpleexpression*) ;
BEGIN (*expression*)
simpleexpression(fsys+[eql,neq,lss,leq,gtr,geq], x);
IF sy IN [eql,neq,lss,leq,gtr,geq] THEN
BEGIN op := sy; insymbol; simpleexpression(fsys, y);
IF (x.typ IN [notyp,ints,bools,chars])
AND (x.typ = y.typ) THEN
CASE op OF
eql: emit(45);
neq: emit(46);
lss: emit(47);
leq: emit(48);
gtr: emit(49);
geq: emit(50);
END ELSE
BEGIN IF x.typ = ints THEN
BEGIN x.typ := reals; emit1(26,1)
END ELSE
IF y.typ = ints THEN
BEGIN y.typ := reals; emit1(26,0)
END ;
IF (x.typ=reals) AND (y.typ=reals) THEN
CASE op OF
eql: emit(39);
neq: emit(40);
lss: emit(41);
leq: emit(42);
gtr: emit(43);
geq: emit(44);
END
ELSE error(35)
END ;
x.typ := bools
END
END (*expression*) ;
PROCEDURE assignment(lv,ad: integer);
VAR x,y: item; f: integer;
(*tab[i].obj in [variable,prozedure]*)
BEGIN x.typ := tab[i].typ; x.ref := tab[i].ref;
IF tab[i].normal THEN f := 0 ELSE f := 1;
emit2(f, lv, ad);
IF sy IN [lbrack,lparent,period] THEN
selector([becomes,eql]+fsys, x);
IF sy = becomes THEN insymbol ELSE
BEGIN error(51); IF sy = eql THEN insymbol
END ;
expression(fsys, y);
IF x.typ = y.typ THEN
IF x.typ IN stantyps THEN emit(38) ELSE
IF x.ref <> y.ref THEN error(46) ELSE
IF x.typ = arrays THEN emit1(23, atab[x.ref].size)
ELSE emit1(23, btab[x.ref].vsize)
ELSE
IF (x.typ=reals) AND (y.typ=ints) THEN
BEGIN emit1(26,0); emit(38)
END ELSE
IF (x.typ<>notyp) AND (y.typ<>notyp) THEN error(46)
END (*assignment*) ;
PROCEDURE compoundstatement;
BEGIN insymbol;
statement([semicolon,endsy]+fsys);
WHILE sy IN [semicolon]+statbegsys DO
BEGIN IF sy = semicolon THEN insymbol ELSE error(14);
statement([semicolon,endsy]+fsys)
END ;
IF sy = endsy THEN insymbol ELSE error(57)
END (*compoundstatemenet*) ;
PROCEDURE ifstatement;
VAR x: item; lc1,lc2: integer;
BEGIN insymbol;
expression(fsys+[thensy,dosy], x);
IF NOT (x.typ IN [bools,notyp]) THEN error(17);
lc1 := lc; emit(11); (*jmpc*)
IF sy = thensy THEN insymbol ELSE
BEGIN error(52); IF sy = dosy THEN insymbol
END ;
statement(fsys+[elsesy]);
IF sy = elsesy THEN
BEGIN insymbol; lc2 := lc; emit(10);
code[lc1].y := lc; statement(fsys); code[lc2].y := lc
END
ELSE code[lc1].y := lc
END (*ifstatement*) ;
PROCEDURE casestatement;
VAR x: item;
i,j,k,lc1: integer;
casetab: ARRAY [1..csmax] OF
PACKED RECORD val, lc: index END ;
exittab: ARRAY [1..csmax] OF integer;
PROCEDURE caselabel;
VAR lab: conrec; k: integer;
BEGIN constant(fsys+[comma,colon], lab);
IF lab.tp <> x.typ THEN error(47) ELSE
IF i = csmax THEN fatal(6) ELSE
BEGIN i := i+1; k := 0;
casetab[i].val := lab.i; casetab[i].lc := lc;
REPEAT k := k+1 UNTIL casetab[k].val = lab.i;
IF k < i THEN error(1); (*multiple definition*)
END
END (*caselabel*) ;
PROCEDURE onecase;
BEGIN IF sy IN constbegsys THEN
BEGIN caselabel;
WHILE sy = comma DO
BEGIN insymbol; caselabel
END ;
IF sy = colon THEN insymbol ELSE error(5);
statement([semicolon,endsy]+fsys);
j := j+1; exittab[j] := lc; emit(10)
END
END (*onecase*) ;
BEGIN insymbol; i := 0; j := 0;
expression(fsys+[ofsy,comma,colon], x);
IF NOT (x.typ IN [ints,bools,chars,notyp]) THEN error(23);
lc1 := lc; emit(12); (*jmpx*)
IF sy = ofsy THEN insymbol ELSE error(8);
onecase;
WHILE sy = semicolon DO
BEGIN insymbol; onecase
END ;
code[lc1].y := lc;
FOR k := 1 TO i DO
BEGIN emit1(13,casetab[k].val); emit1(13,casetab[k].lc)
END ;
emit1(10,0);
FOR k := 1 TO j DO code[exittab[k]].y := lc;
IF sy = endsy THEN insymbol ELSE error(57)
END (*casestatement*) ;
PROCEDURE repeatstatement;
VAR x: item; lc1: integer;
BEGIN lc1 := lc;
insymbol; statement([semicolon,untilsy]+fsys);
WHILE sy IN [semicolon]+statbegsys DO
BEGIN IF sy = semicolon THEN insymbol ELSE error(14);
statement([semicolon,untilsy]+fsys)
END ;
IF sy = untilsy THEN
BEGIN insymbol; expression(fsys, x);
IF NOT (x.typ IN [bools,notyp]) THEN error(17);
emit1(11,lc1)
END
ELSE error(53)
END (*repeatstatement*) ;
PROCEDURE whilestatement;
VAR x: item; lc1,lc2: integer;
BEGIN insymbol; lc1 := lc;
expression(fsys+[dosy], x);
IF NOT (x.typ IN [bools,notyp]) THEN error(17);
lc2 := lc; emit(11);
IF sy = dosy THEN insymbol ELSE error(54);
statement(fsys); emit1(10,lc1); code[lc2].y := lc
END (*whilestatement*) ;
PROCEDURE forstatement;
VAR cvt: types; x: item;
i,f,lc1,lc2: integer;
BEGIN insymbol;
IF sy = ident THEN
BEGIN i := loc(id); insymbol;
IF i = 0 THEN cvt := ints ELSE
IF tab[i].obj = variable THEN
BEGIN cvt := tab[i].typ;
IF NOT tab[i].normal THEN error(37) ELSE
emit2(0, tab[i].lev, tab[i].adr);
IF NOT (cvt IN [notyp,ints,bools,chars]) THEN error(18)
END ELSE
BEGIN error(37); cvt := ints
END
END ELSE skip([becomes,tosy,downtosy,dosy]+fsys, 2);
IF sy = becomes THEN
BEGIN insymbol; expression([tosy,downtosy,dosy]+fsys, x);
IF x.typ <> cvt THEN error(19);
END ELSE skip([tosy,downtosy,dosy]+fsys, 51);
f := 14;
IF sy IN [tosy, downtosy] THEN
BEGIN IF sy = downtosy THEN f := 16;
insymbol; expression([dosy]+fsys, x);
IF x.typ <> cvt THEN error(19)
END ELSE skip([dosy]+fsys, 55);
lc1 := lc; emit(f);
IF sy = dosy THEN insymbol ELSE error(54);
lc2 := lc; statement(fsys);
emit1(f+1,lc2); code[lc1].y := lc
END (*forstatement*) ;
PROCEDURE standproc(n: integer);
VAR i,f: integer;
x,y: item;
BEGIN
CASE n OF
1,2: BEGIN (*read*)
IF NOT iflag THEN
BEGIN error(20); iflag := true
END ;
IF sy = lparent THEN
BEGIN
REPEAT insymbol;
IF sy <> ident THEN error(2) ELSE
BEGIN i := loc(id); insymbol;
IF i <> 0 THEN
IF tab[i].obj <> variable THEN error(37) ELSE
BEGIN x.typ := tab[i].typ; x.ref := tab[i].ref;
IF tab[i].normal THEN f := 0 ELSE f := 1;
emit2(f, tab[i].lev, tab[i].adr);
IF sy IN [lbrack,lparent,period] THEN
selector(fsys+[comma,rparent], x);
IF x.typ IN [ints,reals,chars,notyp] THEN
emit1(27, ord(x.typ)) ELSE error(41)
END
END ;
test([comma,rparent], fsys, 6);
UNTIL sy <> comma;
IF sy = rparent THEN insymbol ELSE error(4)
END ;
IF n = 2 THEN emit(62)
END ;
3,4: BEGIN (*write*)
IF sy = lparent THEN
BEGIN
REPEAT insymbol;
IF sy = string THEN
BEGIN emit1(24,sleng); emit1(28,inum); insymbol
END ELSE
BEGIN expression(fsys+[comma,colon,rparent], x);
IF NOT (x.typ IN stantyps) THEN error(41);
IF sy = colon THEN
BEGIN insymbol;
expression(fsys+[comma,colon,rparent], y);
IF y.typ <> ints THEN error(43);
IF sy = colon THEN
BEGIN IF x.typ <> reals THEN error(42);
insymbol; expression(fsys+[comma,rparent], y);
IF y.typ <> ints THEN error(43);
emit(37)
END
ELSE emit1(30, ord(x.typ))
END
ELSE emit1(29, ord(x.typ))
END
UNTIL sy <> comma;
IF sy = rparent THEN insymbol ELSE error(4)
END ;
IF n = 4 THEN emit(63)
END ;
END (*case*)
END (*standproc*) ;
BEGIN (*statement*)
IF sy IN statbegsys+[ident] THEN
CASE sy OF
ident: BEGIN i := loc(id); insymbol;
IF i <> 0 THEN
CASE tab[i].obj OF
konstant, type1: error(45);
variable: assignment(tab[i].lev, tab[i].adr);
prozedure:
IF tab[i].lev <> 0 THEN call(fsys, i)
ELSE standproc(tab[i].adr);
funktion:
IF tab[i].ref = display[level] THEN
assignment(tab[i].lev+1, 0) ELSE error(45)
END
END ;
beginsy: compoundstatement;
ifsy: ifstatement;
casesy: casestatement;
whilesy: whilestatement;
repeatsy: repeatstatement;
forsy: forstatement;
END;
test(fsys, [], 14)
END (*statement*) ;
BEGIN (*block*) dx := 5; prt := t;
IF level > lmax THEN fatal(5);
test([lparent,colon,semicolon], fsys, 14);
enterblock; display[level] := b; prb := b;
tab[prt].typ := notyp; tab[prt].ref := prb;
IF (sy = lparent) AND (level > 1) THEN parameterlist;
btab[prb].lastpar := t; btab[prb].psize := dx;
IF isfun THEN
IF sy = colon THEN
BEGIN insymbol; (*function type*)
IF sy = ident THEN
BEGIN x := loc(id); insymbol;
IF x <> 0 THEN
IF tab[x].obj <> type1 THEN error(29) ELSE
IF tab[x].typ IN stantyps THEN tab[prt].typ := tab[x].typ
ELSE error(15)
END ELSE skip([semicolon]+fsys, 2)
END ELSE error(5);
IF sy = semicolon THEN insymbol ELSE error(14);
REPEAT
IF sy = constsy THEN constantdeclaration;
IF sy = typesy THEN typedeclaration;
IF sy = varsy THEN variabledeclaration;
btab[prb].vsize := dx;
WHILE sy IN [proceduresy,functionsy] DO procdeclaration;
test([beginsy], blockbegsys+statbegsys, 56)
UNTIL sy IN statbegsys;
tab[prt].adr := lc;
insymbol; statement([semicolon,endsy]+fsys);
WHILE sy IN [semicolon]+statbegsys DO
BEGIN IF sy = semicolon THEN insymbol ELSE error(14);
statement([semicolon,endsy]+fsys)
END ;
IF sy = endsy THEN insymbol ELSE error(57);
test(fsys+[period], [], 6)
END (*block*) ;
(*-------------------------------------------------------interpret---*)
PROCEDURE interpret;
(*global code, tab, btab*)
LABEL 98; (*trap label*)
VAR ir: order; (*instruction buffer*)
pc: integer; (*program counter*)
t: integer; (*top stack index*)
b: integer; (*base index*)
lncnt, ocnt, blkcnt, chrcnt: integer; (*counters*)
h1,h2,h3,h4: integer;
fld: ARRAY [1..4] OF integer; (*default field widths*)
display: ARRAY [1..lmax] OF integer;
s: ARRAY [1..stacksize] OF (*blockmark: *)
RECORD CASE types OF (* s[b+0] = fct result *)
ints: (i: integer); (* s[b+1] = return adr *)
reals: (r: real); (* s[b+2] = static link *)
bools: (b: boolean); (* s[b+3] = dynamic link*)
chars: (c: char) (* s[b+4] = table index *)
END ;
BEGIN (*interpret*)
s[1].i := 0; s[2].i := 0; s[3].i := -1; s[4].i := btab[1].last;
b := 0; display[1] := 0;
t := btab[2].vsize - 1; pc := tab[s[4].i].adr;
ps := run;
lncnt := 0; ocnt := 0; chrcnt := 0;
fld[1] := 10; fld[2] := 22; fld[3] := 10; fld[4] := 1;
REPEAT ir := code[pc]; pc := pc+1; ocnt := ocnt + 1;
CASE ir.f OF
0: BEGIN (*load address*) t := t+1;
IF t > stacksize THEN ps := stkchk
ELSE s[t].i := display[ir.x] + ir.y
END ;
1: BEGIN (*load value*) t := t+1;
IF t > stacksize THEN ps := stkchk
ELSE s[t] := s[display[ir.x] + ir.y]
END ;
2: BEGIN (*load indirect*) t := t+1;
IF t > stacksize THEN ps := stkchk
ELSE s[t] := s[s[display[ir.x] + ir.y].i]
END ;
3: BEGIN (*update display*)
h1 := ir.y; h2 := ir.x; h3 := b;
REPEAT display[h1] := h3; h1 := h1-1; h3 := s[h3+2].i
UNTIL h1 = h2
END ;
8: CASE ir.y OF
0: s[t].i := abs(s[t].i);
1: s[t].r := abs(s[t].r);
2: s[t].i := sqr(s[t].i);
3: s[t].r := sqr(s[t].r);
4: s[t].b := odd(s[t].i);
5: BEGIN (* s[t].c := chr(s[t].i); *)
IF (s[t].i < 0) OR (s[t].i > 63) THEN ps := inxchk
END ;
6: (* s[t].i := ord(s[t].c) *);
7: s[t].c := succ(s[t].c);
8: s[t].c := pred(s[t].c);
9: s[t].i := round(s[t].r);
10: s[t].i := trunc(s[t].r);
11: s[t].r := sin(s[t].r);
12: s[t].r := cos(s[t].r);
13: s[t].r := exp(s[t].r);
14: s[t].r := ln(s[t].r);
15: s[t].r := sqrt(s[t].r);
16: s[t].r := arctan(s[t].r);
17: BEGIN t := t+1;
IF t > stacksize THEN ps := stkchk ELSE s[t].b := eof(input)
END ;
18: BEGIN t := t+1;
IF t > stacksize THEN ps := stkchk ELSE s[t].b := eoln(input)
END ;
END ;
9: s[t].i := s[t].i + ir.y; (*offset*)
10: pc := ir.y; (*jump*)
11: BEGIN (*conditional jump*)
IF NOT s[t].b THEN pc := ir.y; t := t-1
END ;
12: BEGIN (*switch*) h1 := s[t].i; t := t-1;
h2 := ir.y; h3 := 0;
REPEAT IF code[h2].f <> 13 THEN
BEGIN h3 := 1; ps := caschk
END ELSE
IF code[h2].y = h1 THEN
BEGIN h3 := 1; pc := code[h2+1].y
END ELSE
h2 := h2 + 2
UNTIL h3 <> 0
END ;
14: BEGIN (*for1up*) h1 := s[t-1].i;
IF h1 <= s[t].i THEN s[s[t-2].i].i := h1 ELSE
BEGIN t := t-3; pc := ir.y
END
END ;
15: BEGIN (*for2up*) h2 := s[t-2].i; h1 := s[h2].i + 1;
IF h1 <= s[t].i THEN
BEGIN s[h2].i := h1; pc := ir.y END
ELSE t := t-3;
END ;
16: BEGIN (*for1down*) h1 := s[t-1].i;
IF h1 >= s[t].i THEN s[s[t-2].i].i := h1 ELSE
BEGIN pc := ir.y; t := t-3
END
END ;
17: BEGIN (*for2down*) h2 := s[t-2].i; h1 := s[h2].i - 1;
IF h1 >= s[t].i THEN
BEGIN s[h2].i := h1; pc := ir.y END
ELSE t := t-3;
END ;
18: BEGIN (*mark stack*) h1 := btab[tab[ir.y].ref].vsize;
IF t+h1 > stacksize THEN ps := stkchk ELSE
BEGIN t := t+5; s[t-1].i := h1-1; s[t].i := ir.y
END
END ;
19: BEGIN (*call*) h1 := t - ir.y; (*h1 points to base*)
h2 := s[h1+4].i; (*h2 points to tab*)
h3 := tab[h2].lev; display[h3+1] := h1;
h4 := s[h1+3].i + h1;
s[h1+1].i := pc; s[h1+2].i := display[h3]; s[h1+3].i := b;
FOR h3 := t+1 TO h4 DO s[h3].i := 0;
b := h1; t := h4; pc := tab[h2].adr
END ;
20: BEGIN (*index1*) h1 := ir.y; (*h1 points to atab*)
h2 := atab[h1].low; h3 := s[t].i;
IF h3 < h2 THEN ps := inxchk ELSE
IF h3 > atab[h1].high THEN ps := inxchk ELSE
BEGIN t := t-1; s[t].i := s[t].i + (h3-h2)
END
END ;
21: BEGIN (*index*) h1 := ir.y; (*h1 points to atab*)
h2 := atab[h1].low; h3 := s[t].i;
IF h3 < h2 THEN ps := inxchk ELSE
IF h3 > atab[h1].high THEN ps := inxchk ELSE
BEGIN t := t-1; s[t].i := s[t].i + (h3-h2)*atab[h1].elsize
END
END ;
22: BEGIN (*load block*) h1 := s[t].i; t := t-1;
h2 := ir.y + t; IF h2 > stacksize THEN ps := stkchk ELSE
WHILE t < h2 DO
BEGIN t := t+1; s[t] := s[h1]; h1 := h1+1
END
END ;
23: BEGIN (*copy block*) h1 := s[t-1].i;
h2 := s[t].i; h3 := h1 + ir.y;
WHILE h1 < h3 DO
BEGIN s[h1] := s[h2]; h1 := h1+1; h2 := h2+1
END ;
t := t-2
END ;
24: BEGIN (*literal*) t := t+1;
IF t > stacksize THEN ps := stkchk ELSE s[t].i := ir.y
END ;
25: BEGIN (*load real*) t := t+1;
IF t > stacksize THEN ps := stkchk ELSE s[t].r := rconst[ir.y]
END ;
26: BEGIN (*float*) h1 := t - ir.y; s[h1].r := s[h1].i
END ;
27: BEGIN (*read*)
IF eof(input) THEN ps := redchk ELSE
CASE ir.y OF
1: read(s[s[t].i].i);
2: read(s[s[t].i].r);
4: read(s[s[t].i].c);
END ;
t := t-1
END ;
28: BEGIN (*write string*)
h1 := s[t].i; h2 := ir.y; t := t-1;
chrcnt := chrcnt+h1; IF chrcnt > lineleng THEN ps := lngchk;
REPEAT write(stab[h2]); h1 := h1-1; h2 := h2+1
UNTIL h1 = 0
END ;
29: BEGIN (*write1*)
chrcnt := chrcnt + fld[ir.y];
IF chrcnt > lineleng THEN ps := lngchk ELSE
CASE ir.y OF
1: write(s[t].i: fld[1]);
2: write(s[t].r: fld[2]);
3: write(s[t].b: fld[3]);
4: write(chr(s[t].i MOD 64));
END ;
t := t-1
END ;
30: BEGIN (*write2*)
chrcnt := chrcnt + s[t].i;
IF chrcnt > lineleng THEN ps := lngchk ELSE
CASE ir.y OF
1: write(s[t-1].i: s[t].i);
2: write(s[t-1].r: s[t].i);
3: write(s[t-1].b: s[t].i);
4: write(chr(s[t-1].i MOD 64): s[t].i);
END ;
t := t-2
END ;
31: ps := fin;
32: BEGIN (*exit procedure*)
t := b-1; pc := s[b+1].i; b := s[b+3].i
END ;
33: BEGIN (*exit function*)
t := b; pc := s[b+1].i; b := s[b+3].i
END ;
34: s[t] := s[s[t].i];
35: s[t].b := NOT s[t].b;
36: s[t].i := - s[t].i;
37: BEGIN chrcnt := chrcnt + s[t-1].i;
IF chrcnt > lineleng THEN ps := lngchk ELSE
write(s[t-2].r: s[t-1].i: s[t].i);
t := t-3
END ;
38: BEGIN (*store*) s[s[t-1].i] := s[t]; t := t-2
END ;
39: BEGIN t := t-1; s[t].b := s[t].r = s[t+1].r
END ;
40: BEGIN t := t-1; s[t].b := s[t].r <> s[t+1].r
END ;
41: BEGIN t := t-1; s[t].b := s[t].r < s[t+1].r
END ;
42: BEGIN t := t-1; s[t].b := s[t].r <= s[t+1].r
END ;
43: BEGIN t := t-1; s[t].b := s[t].r > s[t+1].r
END ;
44: BEGIN t := t-1; s[t].b := s[t].r >= s[t+1].r
END ;
45: BEGIN t := t-1; s[t].b := s[t].i = s[t+1].i
END ;
46: BEGIN t := t-1; s[t].b := s[t].i <> s[t+1].i
END ;
47: BEGIN t := t-1; s[t].b := s[t].i < s[t+1].i
END ;
48: BEGIN t := t-1; s[t].b := s[t].i <= s[t+1].i
END ;
49: BEGIN t := t-1; s[t].b := s[t].i > s[t+1].i
END ;
50: BEGIN t := t-1; s[t].b := s[t].i >= s[t+1].i
END ;
51: BEGIN t := t-1; s[t].b := s[t].b OR s[t+1].b
END ;
52: BEGIN t := t-1; s[t].i := s[t].i + s[t+1].i
END ;
53: BEGIN t := t-1; s[t].i := s[t].i - s[t+1].i
END ;
54: BEGIN t := t-1; s[t].r := s[t].r + s[t+1].r;
END ;
55: BEGIN t := t-1; s[t].r := s[t].r - s[t+1].r;
END ;
56: BEGIN t := t-1; s[t].b := s[t].b AND s[t+1].b
END ;
57: BEGIN t := t-1; s[t].i := s[t].i * s[t+1].i
END ;
58: BEGIN t := t-1;
IF s[t+1].i = 0 THEN ps := divchk ELSE
s[t].i := s[t].i DIV s[t+1].i
END ;
59: BEGIN t := t-1;
IF s[t+1].i = 0 THEN ps := divchk ELSE
s[t].i := s[t].i MOD s[t+1].i
END ;
60: BEGIN t := t-1; s[t].r := s[t].r * s[t+1].r;
END ;
61: BEGIN t := t-1; s[t].r := s[t].r / s[t+1].r;
END ;
62: IF eof(input) THEN ps := redchk ELSE readln;
63: BEGIN writeln; lncnt := lncnt + 1; chrcnt := 0;
IF lncnt > linelimit THEN ps := linchk
END
END (*case*) ;
UNTIL ps <> run;
98: IF ps <> fin THEN
BEGIN writeln;
write(' halt at', pc:5, ' because of ');
CASE ps OF
run: writeln('error (see dayfile)');
caschk: writeln('undefined case');
divchk: writeln('division by 0');
inxchk: writeln('invalid index');
stkchk: writeln('storage overflow');
linchk: writeln('too much output');
lngchk: writeln('line too long');
redchk: writeln('reading past end of file');
iopr : writeln('illegal operation');
igdm : writeln('guard mode or undefined sequence');
ifof : writeln('floating point overflow');
ifuf : writeln('floating point underflow');
idof : writeln('divide fault (div. by zero or overflow)');
ioerr : writeln('i/o call error');
symberr:writeln('symbiont call error');
errcall:writeln('call on err$');
END ;
h1 := b; blkcnt := 10; (*post mortem dump*)
REPEAT writeln; blkcnt := blkcnt - 1;
IF blkcnt = 0 THEN h1 := 0; h2 := s[h1+4].i;
IF h1<>0 THEN
writeln(' ', tab[h2].name, ' called at', s[h1+1].i: 5);
h2 := btab[tab[h2].ref].last;
WHILE h2 <> 0 DO
WITH tab[h2] DO
BEGIN IF obj = variable THEN
IF typ IN stantyps THEN
BEGIN write(' ', name, ' = ');
IF normal THEN h3 := h1+adr ELSE h3 := s[h1+adr].i;
CASE typ OF
ints: writeln(s[h3].i);
reals: writeln(s[h3].r);
bools: writeln(s[h3].b);
chars: writeln(chr(s[h3].i MOD 64));
END
END ;
h2 := link
END ;
h1 := s[h1+3].i
UNTIL h1 < 0;
END ;
writeln; writeln(ocnt, ' steps')
END (*interpret*) ;
(*------------------------------------------------------------main----*)
BEGIN (*main*)
writeln('-- pascal-s --');writeln;
key[ 1] := 'and '; key[ 2] := 'array ';
key[ 3] := 'begin '; key[ 4] := 'case ';
key[ 5] := 'const '; key[ 6] := 'div ';
key[ 8] := 'downto '; key[ 7] := 'do ';
key[ 9] := 'else '; key[10] := 'end ';
key[11] := 'for '; key[12] := 'function ';
key[13] := 'if '; key[14] := 'mod ';
key[15] := 'not '; key[16] := 'of ';
key[17] := 'or '; key[18] := 'procedure ';
key[19] := 'program '; key[20] := 'record ';
key[21] := 'repeat '; key[22] := 'then ';
key[23] := 'to '; key[24] := 'type ';
key[25] := 'until '; key[26] := 'var ';
key[27] := 'while ';
ksy[ 1] := andsy; ksy[ 2] := arraysy;
ksy[ 3] := beginsy; ksy[ 4] := casesy;
ksy[ 5] := constsy; ksy[ 6] := idiv;
ksy[ 8] := downtosy; ksy[ 7] := dosy;
ksy[ 9] := elsesy; ksy[10] := endsy;
ksy[11] := forsy; ksy[12] := functionsy;
ksy[13] := ifsy; ksy[14] := imod;
ksy[15] := notsy; ksy[16] := ofsy;
ksy[17] := orsy; ksy[18] := proceduresy;
ksy[19] := programsy; ksy[20] := recordsy;
ksy[21] := repeatsy; ksy[22] := thensy;
ksy[23] := tosy; ksy[24] := typesy;
ksy[25] := untilsy; ksy[26] := varsy;
ksy[27] := whilesy;
sps['+'] := plus; sps['-'] := minus;
sps['*'] := times; sps['/'] := rdiv;
sps['('] := lparent; sps[')'] := rparent;
sps['='] := eql; sps[','] := comma;
sps['['] := lbrack; sps[']'] := rbrack;
sps['"'] := neq; sps['&'] := andsy;
sps[';'] := semicolon;
constbegsys := [plus,minus,intcon,realcon,charcon,ident];
typebegsys := [ident,arraysy,recordsy];
blockbegsys := [constsy,typesy,varsy,proceduresy,functionsy,beginsy];
facbegsys := [intcon,realcon,charcon,ident,lparent,notsy];
statbegsys := [beginsy,ifsy,whilesy,repeatsy,forsy,casesy];
stantyps := [notyp,ints,reals,bools,chars];
lc := 0; ll := 0; cc := 0; ch := ' ';
errpos := 0; errs := [];
t := -1; a := 0; b := 1; sx := 0; c2 := 0;
display[0] := 1; reset(input); insymbol;
iflag := false; oflag := false; skipflag := false;
IF sy <> programsy THEN error(3) ELSE
BEGIN insymbol;
IF sy <> ident THEN error(2) ELSE
BEGIN progname := id; insymbol;
IF sy <> lparent THEN error(9) ELSE
REPEAT insymbol;
IF sy <> ident THEN error(2) ELSE
BEGIN IF id = 'input ' THEN iflag := true ELSE
IF id = 'output ' THEN oflag := true ELSE error(0);
insymbol
END
UNTIL sy <> comma;
IF sy = rparent THEN insymbol ELSE error(4);
IF NOT oflag THEN error(20)
END
END ;
enter(' ', variable, notyp, 0); (*sentinel*)
enter('false ', konstant, bools, 0);
enter('true ', konstant, bools, 1);
enter('real ', type1, reals, 1);
enter('char ', type1, chars, 1);
enter('boolean ', type1, bools, 1);
enter('integer ', type1, ints , 1);
enter('abs ', funktion, reals,0);
enter('sqr ', funktion, reals,2);
enter('odd ', funktion, bools,4);
enter('chr ', funktion, chars,5);
enter('ord ', funktion, ints, 6);
enter('succ ', funktion, chars,7);
enter('pred ', funktion, chars,8);
enter('round ', funktion, ints, 9);
enter('trunc ', funktion, ints, 10);
enter('sin ', funktion, reals, 11);
enter('cos ', funktion, reals, 12);
enter('exp ', funktion, reals, 13);
enter('ln ', funktion, reals, 14);
enter('sqrt ', funktion, reals, 15);
enter('arctan ', funktion, reals, 16);
enter('eof ', funktion, bools, 17);
enter('eoln ', funktion, bools, 18);
enter('read ', prozedure, notyp, 1);
enter('readln ', prozedure, notyp, 2);
enter('write ', prozedure, notyp, 3);
enter('writeln ', prozedure, notyp, 4);
enter(' ', prozedure, notyp, 0);
WITH btab[1] DO
BEGIN last := t; lastpar := 1; psize := 0; vsize := 0
END ;
block(blockbegsys+statbegsys, false, 1);
IF sy <> period THEN error(22);
emit(31); (*halt*)
IF btab[2].vsize > stacksize THEN error(49);
IF progname = 'test0 ' THEN printtables;
IF errs = [] THEN
BEGIN
IF iflag THEN
IF eof(input) THEN writeln(' input data missing') ;
writeln(' (eof)'); writeln;
interpret
END
ELSE errormsg;
99: writeln
END .